unit stack;
interface
uses classes,sysutils,vm;

procedure stackwords(vm:TKsanaForthVM);

implementation

procedure forth_spat(vm:TKsanaForthVM);
begin vm.push(vm.sp); //get value of range [-1..255], -1 as empty
end;
procedure forth_spstore(vm:TKsanaForthVM);
begin vm.sp:=vm.pop; //put value of range [-1..255], -1 as empty
end;
procedure forth_drop(vm:TKsanaForthVM);
begin dec(vm.sp);
end;
procedure forth_dup(vm:TKsanaForthVM);
begin vm.push(vm.tos);
end;
procedure forth_qdup(vm:TKsanaForthVM);
begin if vm.tos<>0 then vm.push(vm.tos);
end;
procedure forth_over(vm:TKsanaForthVM);
begin vm.push(vm.sec);
end;
procedure forth_swap(vm:TKsanaForthVM);
begin vm.swap;
end;
procedure forth_2dup(vm:TKsanaForthVM);
var t:integer;
begin t:=vm.tos; vm.push(vm.sec); vm.push(t);
end;
{$IFDEF ANSI_FORTH}
procedure forth_rot(vm:TKsanaForthVM);
var t,s,n:integer;
begin t:=vm.pop; s:=vm.tos; n:=vm.sec;
      vm.sec:=s; vm.tos:=t; vm.push(n);
end;
procedure forth_pick(vm:TKsanaForthVM);
begin vm.tos:=vm.dstack[(vm.sp-vm.tos-1) and STACKIDX_MASK];
end;
procedure forth_drot(vm:TKsanaForthVM);
var t,s,n:integer;
begin t:=vm.pop; s:=vm.tos; n:=vm.sec;
      vm.sec:=t; vm.tos:=n; vm.push(s);
end;
procedure forth_roll(vm:TKsanaForthVM);
var j,k,n,t:integer;
begin n:=vm.pop; if n<=0 then exit;
      j:=(vm.sp-n) and STACKIDX_MASK;
      t:=vm.dstack[j];
      while n>=0 do begin
        dec(n); k:=j; inc(j);
        vm.dstack[k]:=vm.dstack[j and STACKIDX_MASK];
      end;
      vm.tos:=t;
end;
procedure forth_2drop(vm:TKsanaForthVM);
begin dec(vm.sp,2);
end;

procedure forth_2over(vm:TKsanaForthVM);
var t,s,t1,s1:integer;
begin t:=vm.pop;  s:=vm.pop;  t1:=vm.tos;  s1:=vm.sec;
      vm.push(s); vm.push(t); vm.push(s1); vm.push(t1);
end;
procedure forth_2swap(vm:TKsanaForthVM);
var t,s,t1,s1:integer;
begin t:=vm.pop;  s:=vm.pop; t1:=vm.tos;  vm.tos:=t;
      s1:=vm.sec; vm.sec:=s; vm.push(s1); vm.push(t1);
end;
{$ENDIF}

procedure forth_rat(vm:TKsanaForthVM);
begin vm.push(vm.rtos);
end;
procedure forth_rfrom(vm:TKsanaForthVM);
begin vm.push(vm.rpop);
end;
procedure forth_tor(vm:TKsanaForthVM);
begin vm.rpush(vm.pop);
end;
procedure forth_rpat(vm:TKsanaForthVM);
begin vm.push(vm.rp); //get value of range [-1..255], -1 as empty
end;
procedure forth_rpstore(vm:TKsanaForthVM);
begin vm.rp:=vm.pop; //put value of range [-1..255], -1 as empty
end;
procedure forth_duptor(vm:TKsanaForthVM);
begin vm.rpush(vm.tos);
end;
procedure stackwords(vm:TKsanaForthVM);
begin
  vm.addcodeword('rp@'  ,integer(@forth_rpat   )); //// ( -- rp }
  vm.addcodeword('rp!'  ,integer(@forth_rpstore),false,true); //// ( rp -- )
  vm.addcodeword('>r'   ,integer(@forth_tor    ),false,true); //// ( n -- )
  vm.addcodeword('r>'   ,integer(@forth_rfrom  ),false,true); //// ( -- n )
  vm.addcodeword('r@'   ,integer(@forth_rat    )); //// ( -- n )
  vm.addcodeword('dup>r',integer(@forth_duptor ),false,true); //// ( n -- n )

  vm.addcodeword('sp@'  ,integer(@forth_spat   )); //// ( -- sp )
  vm.addcodeword('sp!'  ,integer(@forth_spstore)); //// ( sp -- )
  vm.addcodeword('drop' ,integer(@forth_drop   )); //// ( n -- )
  vm.addcodeword('dup'  ,integer(@forth_dup    )); //// ( n -- n n )
  vm.addcodeword('?dup' ,integer(@forth_qdup   )); //// ( n -- 0 | n n )
  vm.addcodeword('over' ,integer(@forth_over   )); //// ( i j -- i j i )
  vm.addcodeword('swap' ,integer(@forth_swap   )); //// ( i j -- j i )

{$IFDEF ANSI_FORTH}
  vm.addcodeword('pick' ,integer(@forth_pick   )); //// ( ik ... i2 i1 i0 k -- ik )
  vm.addcodeword('rot'  ,integer(@forth_rot    )); //// ( i j k -- j k i )
  vm.addcodeword('-rot' ,integer(@forth_drot   )); //// ( i j k -- k i j )
  vm.addcodeword('roll' ,integer(@forth_roll   )); //// ( ik ... i2 i1 i0 k -- ... i2 i1 i0 ik )
  vm.addcodeword('2dup' ,integer(@forth_2dup   )); //// ( i j -- i j i j )
  vm.addcodeword('2over',integer(@forth_2over  )); //// ( i1 i2 i3 i4 -- i1 i2 i3 i4 i1 i2 )
  vm.addcodeword('2swap',integer(@forth_2swap  )); //// ( i1 i2 i3 i4 -- i3 i4 i1 i2 )
  vm.addcodeword('2drop',integer(@forth_2drop  )); //// ( i j -- )
{$ENDIF}
end;

end.


